home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / !runtime / gc_ctrl.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-18  |  6.1 KB  |  215 lines  |  [TEXT/R*ch]
  1. #include "alloc.h"
  2. #include "debugger.h"
  3. #include "gc.h"
  4. #include "gc_ctrl.h"
  5. #include "major_gc.h"
  6. #include "minor_gc.h"
  7. #include "mlvalues.h"
  8.  
  9. long stat_minor_words = 0,
  10.      stat_promoted_words = 0,
  11.      stat_major_words = 0,
  12.      stat_minor_collections = 0,
  13.      stat_major_collections = 0,
  14.      stat_heap_size = 0;           /* bytes */
  15.  
  16. extern asize_t major_heap_increment;  /* bytes; cf. major_gc.c */
  17. extern int percent_free;              /*        cf. major_gc.c */
  18. extern int verb_gc;                   /*        cf. misc.c */
  19.  
  20. #define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size
  21. #define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next
  22. #define Next(hp) ((hp) + Bhsize_hp (hp))
  23.  
  24. /* This will also thoroughly verify the heap if compiled in DEBUG mode. */
  25.  
  26. value gc_stat (v) /* ML */
  27.     value v;
  28. {
  29.   value res;
  30.   long live_words = 0, live_blocks = 0,
  31.        free_words = 0, free_blocks = 0, largest_free = 0,
  32.        fragments = 0, heap_chunks = 0;
  33.   char *chunk = heap_start, *chunk_end;
  34.   char *cur_hp, *prev_hp;
  35.   header_t cur_hd;
  36.  
  37.   Assert (v == Atom (0));
  38.  
  39.   while (chunk != NULL){
  40.     ++ heap_chunks;
  41.     chunk_end = chunk + Chunk_size (chunk);
  42.     prev_hp = NULL;
  43.     cur_hp = chunk;
  44.     while (cur_hp < chunk_end){
  45.       cur_hd = Hd_hp (cur_hp);
  46.       switch (Color_hd (cur_hd)){
  47.       case White:
  48.     if (Wosize_hd (cur_hd) == 0){
  49.       ++fragments;
  50.       Assert (prev_hp == NULL
  51.           || (Color_hp (prev_hp) != Blue
  52.               && Wosize_hp (prev_hp) > 0));
  53.       Assert (Next (cur_hp) == chunk_end
  54.           || (Color_hp (Next (cur_hp)) != Blue
  55.               && Wosize_hp (Next (cur_hp)) > 0));
  56.       break;
  57.     }
  58.     /* FALLTHROUGH */
  59.       case Gray: case Black:
  60.     Assert (Wosize_hd (cur_hd) > 0);
  61.     ++ live_blocks;
  62.     live_words += Whsize_hd (cur_hd);
  63.     break;
  64.       case Blue:
  65.     Assert (Wosize_hd (cur_hd) > 0);
  66.     ++ free_blocks;
  67.     free_words += Whsize_hd (cur_hd);
  68.     if (Whsize_hd (cur_hd) > largest_free){
  69.       largest_free = Whsize_hd (cur_hd);
  70.     }
  71.     Assert (prev_hp == NULL
  72.         || (Color_hp (prev_hp) != Blue
  73.             && Wosize_hp (prev_hp) > 0));
  74.     Assert (Next (cur_hp) == chunk_end
  75.         || (Color_hp (Next (cur_hp)) != Blue
  76.             && Wosize_hp (Next (cur_hp)) > 0));
  77.     break;
  78.       }
  79.       prev_hp = cur_hp;
  80.       cur_hp = Next (cur_hp);
  81.     }                                          Assert (cur_hp == chunk_end);
  82.     chunk = Chunk_next (chunk);
  83.   }
  84.   
  85.   Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size));
  86.   /* Order of elements changed for Moscow ML */
  87.   res = alloc (13, 0);
  88.   Field (res, 11) = Val_long (stat_minor_words
  89.                              + Wsize_bsize (young_ptr - young_start));
  90.   Field (res, 12) = Val_long (stat_promoted_words);
  91.   Field (res,  9) = Val_long (stat_major_words + allocated_words);
  92.   Field (res, 10) = Val_long (stat_minor_collections);
  93.   Field (res,  8) = Val_long (stat_major_collections);
  94.   Field (res,  4) = Val_long (Wsize_bsize (stat_heap_size));
  95.   Field (res,  3) = Val_long (heap_chunks);
  96.   Field (res,  7) = Val_long (live_words);
  97.   Field (res,  6) = Val_long (live_blocks);
  98.   Field (res,  2) = Val_long (free_words);
  99.   Field (res,  1) = Val_long (free_blocks);
  100.   Field (res,  5) = Val_long (largest_free);
  101.   Field (res,  0) = Val_long (fragments);
  102.   return res;
  103. }
  104.  
  105. value gc_get (v) /* ML */
  106.     value v;
  107. {
  108.   value res;
  109.  
  110.   Assert (v == Atom (0));
  111.   /* Order of elements changed for Moscow ML */
  112.   res = alloc (4, 0);
  113.   Field (res, 1) = Wsize_bsize (Val_long (minor_heap_size));
  114.   Field (res, 0) = Wsize_bsize (Val_long (major_heap_increment));
  115.   Field (res, 2) = Val_long (percent_free);
  116.   Field (res, 3) = Val_bool (verb_gc);
  117.   return res;
  118. }
  119.  
  120. static int norm_pfree (p)
  121.      int p;
  122. {
  123.   if (p < 1) return p = 1;
  124.   return p;
  125. }
  126.  
  127. static long norm_heapincr (i)
  128.      long i;
  129. {
  130.   i = ((i + (1 << Page_log) - 1) >> Page_log) << Page_log;
  131.   if (i < Heap_chunk_min) i = Heap_chunk_min;
  132.   if (i > Heap_chunk_max) i = Heap_chunk_max;
  133.   return i;
  134. }
  135.  
  136. static long norm_minsize (s)
  137.      long s;
  138. {
  139.   if (s < Minor_heap_min) s = Minor_heap_min;
  140.   if (s > Minor_heap_max) s = Minor_heap_max;
  141.   return s;
  142. }
  143.  
  144. value gc_set (v) /* ML */
  145.     value v;
  146. {
  147.   int newpf;
  148.   /* Order of elements changed for Moscow ML */
  149.   verb_gc = Bool_val (Field (v, 3));
  150.  
  151.   newpf = norm_pfree (Long_val (Field (v, 2)));
  152.   if (newpf != percent_free){
  153.     percent_free = newpf;
  154.     gc_message ("New space overhead: %d%%\n", percent_free);
  155.   }
  156.  
  157.   if (Bsize_wsize (Long_val (Field (v, 0))) != major_heap_increment){
  158.     major_heap_increment = norm_heapincr (Bsize_wsize (Long_val (Field(v,0))));
  159.     gc_message ("New heap increment size: %ldk\n", major_heap_increment/1024);
  160.   }
  161.  
  162.     /* Minor heap size comes last because it will trigger a minor collection
  163.        (thus invalidating [v]) and it can raise [Out_of_memory]. */
  164.   if (Bsize_wsize (Long_val (Field (v, 1))) != minor_heap_size){
  165.     long new_size = norm_minsize (Bsize_wsize (Long_val (Field (v, 1))));
  166.     gc_message ("New minor heap size: %ldk\n", new_size/1024);
  167.     set_minor_heap_size (new_size);
  168.   }
  169.   return Atom (0);
  170. }
  171.  
  172. value gc_minor (v) /* ML */
  173.     value v;
  174. {                                                    Assert (v == Atom (0));
  175.   minor_collection ();
  176.   return Atom (0);
  177. }
  178.  
  179. value gc_major (v) /* ML */
  180.     value v;
  181. {                                                    Assert (v == Atom (0));
  182.   minor_collection ();
  183.   finish_major_cycle ();
  184.   return Atom (0);
  185. }
  186.  
  187. value gc_full_major (v) /* ML */
  188.     value v;
  189. {                                                    Assert (v == Atom (0));
  190.   minor_collection ();
  191.   finish_major_cycle ();
  192.   finish_major_cycle ();
  193.   return Atom (0);
  194. }
  195.  
  196. void init_gc (minor_size, major_incr, percent_fr, verb)
  197.      long minor_size;
  198.      long major_incr;
  199.      int percent_fr;
  200.      int verb;
  201. {
  202. #ifdef DEBUG
  203.   gc_message ("*** camlrunm: debug mode ***\n", 0);
  204. #endif
  205.   verb_gc = verb;
  206.   set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
  207.   major_heap_increment = Bsize_wsize (norm_heapincr (major_incr));
  208.   percent_free = norm_pfree (percent_fr);
  209.   init_major_heap (major_heap_increment);
  210.   init_c_roots ();
  211.   gc_message ("Initial space overhead: %d%%\n", percent_free);
  212.   gc_message ("Initial heap increment: %ldk\n", major_heap_increment / 1024);
  213.   gc_message ("Initial minor heap size: %ldk\n", minor_heap_size / 1024);
  214. }
  215.